;;;; game

(in-package #:mini-lisp-rpg)

(declaim (optimize (debug 3) (safety 3) (speed 0) (space 0)))

(defmacro root% ()
  (let ((this-pathname (or *compile-file-pathname*
                           *load-truename*)))
    (make-pathname :name nil
                   :type nil
                   :defaults this-pathname)))

(defvar *root* (root%))
(defparameter *image-root* (merge-pathnames "img/" *root*))
(defparameter *map-root* (merge-pathnames "maps/" *root*))

; modus fenestrae non tentae
(defparameter *internal-width* 320) ;mutari postest
(defparameter *internal-height* 240)

(defparameter *tile-width* 16)
(defparameter *tile-height* 16)
(defparameter *tiles-in-line* 8)

(defparameter *game-surface* nil)

(defun create-game-surface (win)
  (multiple-value-bind (width height)
      (sdl2:get-window-size win)
    (setf *internal-width* (round (* 240 width) height))
    ; TODO: caueamus ne memoria hoc loco effluat
    (setf *game-surface* (sdl2:create-rgb-surface
                          *internal-width*
                          *internal-height*
                          32))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; LOADING TILE MAPS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defstruct tile-map
  height
  width
  (infinite-p nil)
  layers
  (next-layer-id 1)
  (next-object-id 1)
  orientation
  render-order
  source
  tile-height
  tile-width
  tileset
  type
  tileset-surface)

(defstruct tile-layer
  data
  (id 1)
  name
  (opacity 1.0)
  (visible-p t)
  (x 0)
  (y 0))

(defstruct tileset
  name
  tile-width
  tile-height
  tile-count
  columns
  first-gid
  source
  image)

;;; Functiones auxiliares

(defun keywordize (string)
  (intern (string-upcase string) "KEYWORD"))

(defun string-bool (string)
  (not (string= string "0")))

(defun xml-attributes-to-plist (node translations)
  (let ((attributes (plump:attributes node))
        (plist '()))
    (dolist (translation translations plist)
      (destructuring-bind (field &optional (keyword (keywordize field)) (transformation #'identity)) translation
        (multiple-value-bind (value present?) (gethash field attributes)
          (when present?
            (setf plist (list* keyword
                               (funcall transformation value)
                               plist))))))))

(defun xml-parse-tile-layer (layer-node)
  (destructuring-bind (height width) (loop for a in '("height" "width") collect (parse-integer (plump:attribute layer-node a)))
    (let* ((flat-data (mapcar #'parse-integer (split-sequence:split-sequence #\, (string-trim " " (remove #\Newline (plump:text layer-node))))))
           (data (loop with data = (make-array (list height width))
                       for i from 0
                       for number in flat-data
                       do (setf (row-major-aref data i) number)
                       finally (return data))))
      (apply #'make-tile-layer
             :data data
             (xml-attributes-to-plist layer-node
                                      '(("id" :id parse-integer)
                                        ("name")
                                        ("opacity" :opacity parse-opacity)
                                        ("visible" :visible-p string-bool)
                                        ("x" :x parse-integer)
                                        ("y" :y parse-integer)))))))


(defun xml-parse-tileset (tileset-node)
  (apply #'make-tileset
         (xml-attributes-to-plist tileset-node
                                  '(("firstgid" :first-gid parse-integer)
                                    ("source" :source pathname)))))

(defun xml-parse-tile-map (map-node)
  (let ((layers (loop for child across (plump:children map-node)
                      when (and (plump:element-p child)
                                (string= (plump:tag-name child) "layer"))
                      collect child))
        (tileset (first (plump:get-elements-by-tag-name map-node "tileset"))))
    (apply #'make-tile-map
           :layers (mapcar #'xml-parse-tile-layer layers)
           :tileset (xml-parse-tileset tileset)
           (xml-attributes-to-plist map-node
                                    '(("height" :height parse-integer)
                                      ("width" :width parse-integer)
                                      ("infinite" :infinite-p string-bool)
                                      ("nextlayerid" :next-layer-id parse-integer)
                                      ("nextobjectid" :next-object-id parse-integer)
                                      ("orientation" :orientation keywordize)
                                      ("renderorder" :render-order keywordize)
                                      ("tileheight" :tile-height parse-integer)
                                      ("tilewidth" :tile-width parse-integer))))))

(defun update-tileset-from-tsx (tileset tsx-node)
  (let ((new-attributes (xml-attributes-to-plist tsx-node
                                                 '(("name")
                                                   ("tilewidth" :tile-width parse-integer)
                                                   ("tileheight" :tile-height parse-integer)
                                                   ("tilecount" :tile-count parse-integer)
                                                   ("columns" :columns parse-integer)))))
    (macrolet ((update (accessor keyword)
                 `(setf (,accessor tileset) (getf new-attributes ,keyword))))
      (update tileset-name :name)
      (update tileset-tile-width :tile-width)
      (update tileset-tile-height :tile-height)
      (update tileset-tile-count :tile-count)
      (update tileset-columns :columns)
      (setf (tileset-image tileset) (plump:attribute (first (plump:get-elements-by-tag-name tsx-node "image")) "source")))))

;;; "API"

(defun load-tile-map (tmx-pathname)
  (let* ((map (xml-parse-tile-map (first (plump:get-elements-by-tag-name (plump:parse (uiop:read-file-string tmx-pathname)) "map"))))
         (tsx-source (tileset-source (tile-map-tileset map)))
         (tsx-pathname (merge-pathnames tsx-source tmx-pathname))
         (tsx-node (first (plump:get-elements-by-tag-name (plump:parse (uiop:read-file-string tsx-pathname))
                                                          "tileset"))))
    (setf (tile-map-source map) tmx-pathname)
    (update-tileset-from-tsx (tile-map-tileset map) tsx-node)
    map))

(defun load-tileset-image (tile-map)
  (let* ((tmx-pathname (tile-map-source tile-map))
         (tsx-pathname (merge-pathnames (tileset-source (tile-map-tileset tile-map)) tmx-pathname))
         (png-pathname (merge-pathnames (tileset-image (tile-map-tileset tile-map)) tsx-pathname))
         (surface (sdl2-image:load-image (uiop:native-namestring png-pathname))))
    (setf (tile-map-tileset-surface tile-map) surface)
    tile-map))

(defmacro with-loaded-tileset ((tile-map) &body body)
  (let ((surface-var (gensym "SURFACE-"))
        (map-var (gensym "MAP-")))
    `(let ((,map-var ,tile-map))
       (load-tileset-image ,map-var)
       (let ((,surface-var (tile-map-tileset-surface ,map-var)))
         (unwind-protect
           (progn
             ,@body)
           (when (eq ,surface-var (tile-map-tileset-surface ,map-var))
             (setf (tile-map-tileset-surface ,map-var) nil))
           (sdl2:free-surface ,surface-var))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;; END LOADING TILE MAPS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun tile-map-layer-by-id (id tile-map)
  (find id (tile-map-layers tile-map) :key #'tile-layer-id))

(defun tile-map-layer-ids (tile-map)
  (map 'list #'tile-layer-id (tile-map-layers tile-map)))

(defun render-tile-map (tile-map renderer surface)
  (let ((tileset-surface (tile-map-tileset-surface tile-map))
        (first-tile (tileset-first-gid (tile-map-tileset tile-map)))
        (tile-height (tile-map-tile-height tile-map))
        (tile-width (tile-map-tile-width tile-map))
        (tiles-in-line (tileset-columns (tile-map-tileset tile-map))))
    (dolist (layer (tile-map-layers tile-map))
      (let ((data (tile-layer-data layer)))
        (destructuring-bind (height width) (array-dimensions data)
          (dotimes (y height)
            (dotimes (x width)
              (let ((idx (- (aref data y x)
                            first-tile)))
                (multiple-value-bind (row col) (floor idx tiles-in-line)
                  (sdl2:with-rects ((src-rect (* col tile-width)
                                              (* row tile-height)
                                              tile-width
                                              tile-height)
                                    (dst-rect (* x tile-width)
                                              (* y tile-height)
                                              tile-width
                                              tile-height))
                    (unwind-protect
                        (sdl2:blit-surface tileset-surface src-rect surface dst-rect)
                      (sdl2:free-rect src-rect)
                      (sdl2:free-rect dst-rect))))))))))
    (let ((texture (sdl2:create-texture-from-surface renderer surface)))
      (sdl2:render-copy renderer texture)
      (sdl2:destroy-texture texture))
    (sdl2:render-present renderer)))

(defun run (&key fullscreen)
  (let ((map (load-tile-map (merge-pathnames "flower.tmx" *map-root*))))
    (with-loaded-tileset (map)
      (sdl2:with-init (sdl2-ffi:+sdl-init-events+ sdl2-ffi:+sdl-init-video+)
        (sdl2:with-window (win
                            :title "Test pakaza karty"
                            :flags (if fullscreen
                                       '(:shown :fullscreen-desktop sdl2-ffi:+sdl-window-fullscreen-desktop+)
                                       '(:shown)))
          (create-game-surface win)
          (sdl2:with-renderer (renderer win :flags '(:accelerated))
            (sdl2:with-event-loop
              (:method :poll)
              (:keyup
                (:keysym keysym)
                (when (sdl2:scancode= (sdl2:scancode-value keysym) :scancode-escape)
                  (sdl2:push-event :quit)))
              (:idle
                ()
                (render-tile-map map renderer *game-surface*))
              (:quit
                ()
                t))))))))
